home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / ASTRNOMY / HEAT0_1.ZIP / HEAT.F < prev    next >
Text File  |  1993-11-09  |  53KB  |  1,822 lines
  1. c Copyright: October, 1993.
  2.  
  3. c mailing address: 185 N. West Temple #311
  4. c                  Salt Lake City, Utah 84103-1562
  5. c email address: c-wwj @ math.utah.edu (1993)
  6.  
  7. c GNU PUBLIC LICENSE.
  8. c This program "HEAT" is released as copyrighted material under the GNU
  9. c   PUBLIC LICENSE:
  10.                            
  11.  
  12. c                           NO WARRANTY
  13.  
  14. c   Because HEAT is licensed free of charge, absolutely no warranty is
  15. c   provided, to the extent permitted by applicable state law.  Except
  16. c   when otherwise stated in writing, Bill Wigginton provides HEAT "as
  17. c   is" without warranty of any kind, either expressed or implied,
  18. c   including, but not limited to, the implied warranties of
  19. c   merchantability and fitness for a particular purpose.  The entire
  20. c   risk as to the quality and performance of the program is with you.
  21. c   Should the HEAT program prove defective, you assume the cost of all
  22. c   necessary servicing, repair or correction.
  23.  
  24. c   In no event unless required by applicable law will Bill Wigginton
  25. c   and/or any other party who may modify and redistribute HEAT be liable
  26. c   to you for damages, including any lost profits, lost monies, or other
  27. c   special, incidental or consequential damages arising out of the use
  28. c   or inability to use (including but not limited to loss of data or
  29. c   data being rendered inaccurate or losses sustained by third parties
  30. c   or a failure of the program to operate with programs not distributed
  31. c   by Bill Wigginton ) the program, even if you have been advised of the
  32. c   possibility of such damages, or for any claim by any other party.
  33.  
  34. c NO COST?
  35. c   This program is provided free of charge to individuals and
  36. c   educational institutions. Money is not requested.
  37.  
  38.  
  39. c                   S O U R C E     C O D E
  40.  
  41.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  42.      integer   iolog,lincnt
  43.          logical   scrnop,diskop,opened,ltrltr
  44.      character line(1:79)
  45.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  46.      integer maxit, iterno
  47.      real    accfac, cnvrg, bigres
  48.      logical finis,divrg
  49.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  50.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  51.      integer shape,size,vsize,inshp,insize,ivsize,
  52.      +       thick,hthick,vthick,square,circle,rctngl
  53.      logical solid, skewed
  54.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  55.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  56.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  57.      real    temper (1:79,1:79)
  58.      integer tmpshp(1:79,1:8)
  59.                           
  60.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  61.       data square/1/ circle/2/ rctngl/3/
  62.       data els/1/ wlb/2/ wle/3/ ils/4/ irs/5/ wrb/6/ wre/7/ ers/8/
  63.       logical answer, Quit
  64.       character ch
  65.  
  66.       call initio
  67.       call initbs
  68.       call initit
  69.       call initsh
  70. 10    continue
  71.       call clrscr
  72.       Quit = .FALSE.
  73.       print *, ' Enter'
  74.       print *, ' <S> To Solve Heat Problem'
  75.       print *, ' <P> To Plot Output to Disk or Screen'
  76.       print *, ' <L> To List Numerical Data to Disk or Screen'
  77.       print *, ' <Q> To Quit'
  78.       read  *, Ch
  79.       IF (Ch .eq. 'S' .or. Ch .eq. 's') THEN
  80.      call SOLVE
  81.       ELSE IF (Ch .eq. 'P' .or. Ch .eq. 'p') THEN
  82.      call PLOT
  83.       ELSE IF (Ch .eq. 'L' .or. Ch .eq. 'l') THEN
  84.      call LIST
  85.       ELSE IF (Ch .eq. 'Q' .or. Ch .eq. 'q') THEN
  86.      Quit = .TRUE.
  87.       ELSE IF (Ch .eq. '|' .or. Ch .eq. '~') THEN
  88.      call wrtmsh
  89.       ELSE
  90.      call WRONG
  91.       END IF
  92.       IF ( Quit .eq. .FALSE. ) GO TO 10
  93.       call ENDOPT (answer)
  94.       IF (answer .eq. .FALSE.) GO TO 10
  95.       END
  96.  
  97.       SUBROUTINE SOLVE
  98.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  99.      integer maxit, iterno
  100.      real    accfac, cnvrg, bigres
  101.      logical finis,divrg
  102.       integer iter
  103.       logical answer
  104.  
  105.       IF (finis .eq. .FALSE.) THEN 
  106.      call finopt(answer)
  107.      IF (answer .eq. .TRUE.) finis = .TRUE.
  108.       END IF
  109.       call readin
  110.       call initlz
  111.       IF (maxit .eq. 0) return
  112.       IF (finis .eq. .TRUE.) THEN
  113.      iterno = 0
  114.      finis  = .FALSE.
  115.       END IF
  116. 15    continue
  117.       call clrscr
  118.       print *,' Iterating'
  119.       do 20 iter = 1, maxit
  120.      iterno = iterno + 1
  121.      call itrate
  122.      IF ( bigres .lt. cnvrg ) THEN
  123.         finis = .TRUE.
  124.         call beep(2)
  125.         call clrscr
  126.         call wcvrg
  127.         Return
  128.      END IF
  129. 20    continue
  130. 30    continue
  131.       finis = .FALSE.
  132.       call beep(2)
  133.       call clrscr
  134.       call wncvrg
  135.       call conopt (answer)
  136.       IF (answer .eq. .TRUE.) GO TO 15
  137.       END
  138.  
  139.       SUBROUTINE readin
  140.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  141.      integer maxit, iterno
  142.      real    accfac, cnvrg, bigres
  143.      logical finis,divrg
  144.       logical answer
  145.  
  146.       IF (finis .eq. .FALSE.) THEN
  147.      call gtiter
  148.      return
  149.       END IF
  150. 10    continue
  151.       call clrscr
  152.       call wrbas
  153.       call writer
  154.       call wrshp
  155.       call okopt  (answer)
  156.       IF (answer .eq. .TRUE.) GO TO 90
  157.       call gtbas
  158.       call gtiter
  159.       call gtshp
  160.       GO TO 10
  161. 90    continue
  162.       END 
  163.  
  164.       SUBROUTINE initlz
  165.       intrinsic nint, min, max
  166.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  167.      integer maxit, iterno
  168.      real    accfac, cnvrg, bigres
  169.      logical finis,divrg
  170.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  171.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  172.      integer shape,size,vsize,inshp,insize,ivsize,
  173.      +       thick,hthick,vthick,square,circle,rctngl
  174.      logical solid, skewed
  175.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  176.      real intrnt, lowert, uppert, prcnt, mint, maxt
  177.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  178.      real temper (1:79,1:79)
  179.      integer tmpshp(1:79,1:8)
  180.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  181.       integer row,col,rowe,midcol
  182.       real edget,incr,w
  183.  
  184.       IF (finis .eq. .FALSE.) return
  185.       call initts
  186.       call initmp
  187.       mint = min(lowert,uppert,intrnt)
  188.       maxt = max(lowert,uppert,intrnt)
  189.       midcol = (size+1)/2
  190. 5     continue
  191.       GO TO (10,15,10) shape
  192.       print *, ' Shape value = ',shape
  193. 10    continue
  194.       call mkrect(1,1,size,vsize,els,ers)
  195.       GO TO 20
  196. 15    continue
  197.       call mkrnd (1,1,size,els,ers)
  198. 20    continue
  199.       IF (solid .eq. .TRUE.) GO TO 40
  200.       GO TO (25,30,25)inshp
  201. 25    continue
  202.       call mkrect(hthick,vthick,insize,ivsize,ils,irs)
  203.       GO TO 35
  204. 30    continue
  205.       call mkrnd (hthick,vthick,insize,ils,irs)
  206. 35    continue
  207. 40    continue
  208.       call tstskw
  209.       call mkwall
  210.       do 50 col = tmpshp(1,els), midcol
  211.      temper(1,col) = uppert
  212.      temper(1,size-col+1) = uppert
  213. 50    continue   
  214.       w     = vsize * (100 - prcnt) * .01
  215.       rowe  = nint(w) 
  216.       IF (rowe .lt. 2) THEN
  217.      rowe = 1
  218.      GO TO 61
  219.       END IF
  220.       incr  = (uppert - lowert)/rowe
  221.       edget = uppert
  222.       do 60 row = 2, rowe
  223.      edget = edget - incr
  224.       do 55 col = tmpshp(row,els),midcol
  225.      temper(row,col) = edget
  226.      temper(row,size-col+1) = edget
  227. 55    continue
  228. 60    continue
  229. 61    continue
  230.       do 70 row = rowe+1,vsize
  231.       do 65 col = tmpshp(row,els),midcol
  232.      temper(row,col) = lowert
  233.      temper(row,size-col+1) = lowert
  234. 65    continue
  235. 70    continue
  236.       IF (solid .eq. .TRUE.) GO TO 90
  237.       do 80 row = vthick,vthick+ivsize-1
  238.       do 75 col = tmpshp(row,ils),tmpshp(row,irs)
  239.      temper(row,col) = intrnt
  240. 75    continue
  241. 80    continue
  242. 90    continue
  243.       END
  244.  
  245.       SUBROUTINE itrate 
  246.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  247.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  248.      integer shape,size,vsize,inshp,insize,ivsize,
  249.      +       thick,hthick,vthick,square,circle,rctngl
  250.      logical solid, skewed
  251.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  252.      integer maxit, iterno
  253.      real    accfac, cnvrg, bigres
  254.      logical finis,divrg
  255.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  256.      real    temper (1:79,1:79)
  257.      integer tmpshp(1:79,1:8)
  258.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  259.       integer row,col,colm,midcol
  260.  
  261.       bigres = 0
  262.       midcol = (size+1)/2
  263.       IF (skewed .eq. .TRUE.) GO TO 30
  264.       do 20 row = 2,vsize-1
  265.       do 10 col = tmpshp(row,wlb),midcol
  266.      call comput(row,col)
  267.      colm = size-col+1
  268.      temper(row,colm) = temper(row,col)
  269. 10    continue
  270. 20    continue
  271.       return
  272. 30    continue
  273.       do 50 row = 2,vsize-1
  274.       do 40 col = tmpshp(row,wlb),midcol
  275.      call comput(row,col)
  276.      colm = size-col+1
  277.      call comput(row,colm)
  278. 40    continue  
  279. 50    continue
  280.       END
  281.  
  282.       SUBROUTINE comput (row,col)                                         
  283.       intrinsic max,abs
  284.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  285.      integer maxit, iterno
  286.      real    accfac, cnvrg, bigres
  287.      logical finis,divrg
  288.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  289.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  290.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  291.      real temper (1:79,1:79)
  292.      integer tmpshp(1:79,1:8)
  293.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  294.       real tempt
  295.       logical answer
  296.       integer row,col
  297.  
  298.       call inwall(row,col,answer)
  299.       IF (answer .eq. .FALSE.) return
  300.       tempt = (0.25 * accfac) *
  301.      +        (temper(row+1,col) + temper(row-1,col) +
  302.      +         temper(row,col+1) + temper(row,col-1)) +
  303.      +        ((1.0 - accfac) * temper(row, col))
  304.       bigres = max(bigres,abs(tempt-temper(row,col)))
  305.       temper(row,col)=tempt
  306.       END
  307.  
  308.       SUBROUTINE plot
  309.       intrinsic abs, mod
  310.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  311.      integer   iolog,lincnt
  312.      logical   scrnop,diskop,opened,ltrltr
  313.      character line(1:79)
  314.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  315.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  316.      integer shape,size,vsize,inshp,insize,ivsize,
  317.      +       thick,hthick,vthick,square,circle,rctngl
  318.      logical solid, skewed
  319.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  320.      real intrnt, lowert, uppert, prcnt, mint, maxt
  321.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  322.      real temper (1:79,1:79)
  323.      integer tmpshp(1:79,1:8)
  324.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  325.       integer row, col, index
  326.       real tincr
  327.       logical answer
  328.       character*1 blank, symbol(1:17)
  329.      parameter ( blank = ' ' )
  330.       data symbol/ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
  331.      +             'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q' /
  332.  
  333.       call ltropt(ltrltr)
  334.       call gtioop(answer)
  335.       IF (answer .eq. .FALSE.) return
  336.       tincr = abs(maxt-mint)/17
  337.       call clrscr              
  338.       lincnt = 0
  339.       do 30 row = 1, vsize
  340.      call initln
  341.       do 20 col = tmpshp(row,els),tmpshp(row,ers)
  342.      call onwall(row,col,answer)
  343.      IF (answer .eq. .FALSE.) THEN
  344.         line(col) = blank
  345.      ELSE 
  346.      +   IF (temper(row,col) .le. mint) THEN
  347.         index = 1
  348.         line(col) = symbol(index)
  349.      ELSE 
  350.      +   IF (temper(row,col) .ge. maxt) THEN
  351.         index = 17
  352.         line(col) = symbol(index)
  353.      ELSE                              
  354.         index = ((temper(row,col)-mint)/tincr)+1.0
  355.         IF ((ltrltr .eq. .FALSE.) .and. (mod(index,2) .eq. 0)) THEN
  356.            line(col) = blank
  357.         ELSE 
  358.            line(col) = symbol(index)
  359.         END IF
  360.      END IF
  361. 20    continue
  362.       IF (scrnop .eq. .TRUE.) THEN
  363.       IF (lincnt .ge. 20) THEN
  364.          call conopt (answer)
  365.          IF (answer .eq. .FALSE.) GO TO 50
  366.          call clrscr
  367.          lincnt = 0
  368.       END IF
  369.       lincnt = lincnt + 1
  370.       print '(1x,79a1)', line
  371.       END IF
  372.       IF ((diskop .eq. .TRUE.) .and. (opened .eq. .TRUE.))
  373.      +   write (iolog,'(1x,79a1)') line
  374. 30    continue
  375. 50    continue
  376.       call wrltrs(maxt,mint,tincr)
  377.       IF (opened .eq. .TRUE.) call cldisk
  378.       END
  379.  
  380.       SUBROUTINE LIST 
  381.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  382.      integer   iolog,lincnt
  383.      logical   scrnop,diskop,opened,ltrltr
  384.      character line(1:79)
  385.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  386.      integer maxit, iterno
  387.      real    accfac, cnvrg, bigres
  388.      logical finis,divrg
  389.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  390.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  391.      integer shape,size,vsize,inshp,insize,ivsize,
  392.      +       thick,hthick,vthick,square,circle,rctngl
  393.      logical solid, skewed
  394.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  395.      real temper (1:79,1:79)
  396.      integer tmpshp(1:79,1:8)
  397.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  398.       integer row,rowb,rowe,col,colb,cole
  399.       logical answer
  400.  
  401.       call rdlist
  402.       call gtlmts(rowb,colb,rowe,cole)
  403.       call gtioop (answer)
  404.       IF (answer .eq. .FALSE.) return
  405.       IF (opened .eq. .TRUE.) THEN
  406.      do 20 row = rowb,rowe
  407.      do 10 col = colb,cole
  408.         call onwall(row,col,answer)
  409.         IF (answer .eq. .TRUE.) THEN
  410.            write (iolog,'(I3,I3,f11.5)') row, col, temper(row,col)
  411.         END IF
  412. 10       continue      
  413. 20       continue
  414.       call cldisk
  415.       END IF
  416.       IF (scrnop .eq. .TRUE.) THEN
  417.      call clrscr
  418.      lincnt = 0
  419.      do 70 row = rowb,rowe
  420.      do 60 col = colb,cole
  421.      IF (lincnt .ge. 20) THEN
  422.         call conopt (answer)
  423.         IF (answer .eq. .FALSE.) GO TO 90
  424.         call clrscr
  425.         lincnt = 0
  426.      END IF
  427.      call onwall(row,col,answer)
  428.      IF (answer .eq. .TRUE.) THEN
  429.         IF (lincnt .ge. 20) THEN
  430.            call conopt (answer)
  431.            IF (answer .eq. .FALSE.) GO TO 90
  432.            call clrscr
  433.            lincnt = 0
  434.         END IF
  435.         lincnt = lincnt + 1
  436.         print *,' ',row,col,temper(row,col)
  437.      END IF
  438. 60       continue
  439. 70       continue
  440.       END IF
  441. 90    continue
  442.       IF (scrnop .eq. .TRUE.) call prentr
  443.       END
  444.  
  445.       SUBROUTINE OpDskI
  446.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  447.      integer   iolog,lincnt
  448.      logical   scrnop,diskop,opened,ltrltr
  449.      character line(1:79)
  450.       character*50 filenm
  451.       logical answer,unfmt
  452.  
  453.       unfmt = .FALSE.
  454.       print *,' Opening Input File'
  455.       GO TO 10      
  456.       ENTRY OpDskO
  457.       IF (diskop .eq. .FALSE.) THEN
  458.      print *, ' Cannot open disk for output',
  459.      +      ' if the disk option is not set.'
  460.      opened = .FALSE.
  461.      return
  462.       END IF
  463.       print *, ' W A R N I N G ! ! !   W A R N I N G ! ! !'
  464.       print *, ' If the file already exists it WILL BE OVERWRITTEN!'
  465.       call conopt(answer)
  466.       IF (answer .eq. .FALSE.) THEN
  467.      opened = .FALSE.
  468.      return
  469.       END IF
  470.       unfmt = .FALSE.
  471.       print *,' Opening Output File'
  472.       GO TO 10
  473.       ENTRY OpDskU
  474.       unfmt = .TRUE.
  475.       print *,' Opening Unformatted File for Input or Output'
  476.       GO TO 10
  477. 10    continue
  478.       call clrscr
  479. 20    continue
  480.       print *, ' Enter disk path and filename'
  481.       read  *, filenm
  482.       print *, ' Is this the correct path and filename ', filenm
  483.       call yesno(answer)
  484.       IF (answer .eq. .FALSE.) GO TO 20
  485.       IF (unfmt .eq. .TRUE.) THEN
  486.      open (UNIT=iolog, FILE=filenm, FORM='UNFORMATTED', ERR=30,
  487.      +         STATUS='UNKNOWN')
  488.       ELSE
  489.      open (UNIT=iolog, STATUS='UNKNOWN', FILE=filenm, ERR=30)
  490.       END IF
  491.       print *,' File ',filenm,' successfully opened.'
  492.       opened = .TRUE.
  493.       return
  494. 30    continue
  495.       print *, ' Error opening disk file ', filenm
  496.       opened = .FALSE.
  497.       call tryopt (answer)
  498.       IF (answer .eq. .TRUE.) GO TO 20
  499.       END
  500.  
  501.       SUBROUTINE ClDisk
  502.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  503.      integer   iolog,lincnt
  504.      logical   scrnop,diskop,opened,ltrltr
  505.      character line(1:79)
  506.  
  507.       IF ((diskop .eq. .TRUE.) .and. (opened .eq. .TRUE.)) THEN
  508.      close(iolog)
  509.      call beep(1)
  510.      diskop = .FALSE.
  511.      opened = .FALSE.
  512.       END IF
  513.       END
  514.  
  515.       SUBROUTINE getans (answer)
  516.      logical answer
  517.      GO TO 90
  518.       ENTRY okopt  (answer)
  519.      print *, ' Is everything all right?'
  520.      GO TO 90
  521.       ENTRY tryopt (answer)
  522.      print *, ' Do you wish to try it again?'
  523.      GO TO 90
  524.       ENTRY conopt (answer)
  525.      print *, ' Do you wish to continue?'
  526.      GO TO 90
  527.       ENTRY endopt (answer)
  528.      print *, ' Do you really wish to end all this?'
  529.      GO TO 90
  530.       ENTRY scropt (answer)
  531.      print *, ' Do you wish screen output?'
  532.      GO TO 90
  533.       ENTRY dskopt (answer)
  534.      print *, ' Do you wish disk output?'
  535.      GO TO 90
  536.       ENTRY ltropt (answer)
  537.      print *, ' Do you wish letter to letter plot?'
  538.      GO TO 90
  539.       ENTRY lstopt (answer)
  540.      print *, ' Do you wish to read the list data from disk?'
  541.      GO TO 90
  542.       ENTRY limopt (answer)
  543.      print *, ' Do you wish to list all of the values?'
  544.      GO TO 90
  545.       ENTRY solopt (answer)
  546.      print *, ' Is the shield solid?'
  547.      GO TO 90
  548.       ENTRY basopt (answer)
  549.      print *, ' Do you wish to modify the basic options?'
  550.      GO TO 90
  551.       ENTRY itropt (answer)
  552.      print *, ' Do you wish to modify the iteration control?'
  553.      GO TO 90
  554.       ENTRY shpopt (answer)
  555.      print *, ' Do you wish to modify the shield size or shape?'
  556.      GO TO 90
  557.       ENTRY finopt (answer)
  558.      print *, ' There is a solution still in progress.'
  559.      print *, ' Do you wish to end the previous solution?'
  560.      GO TO 90
  561. 90    continue
  562.       call yesno (answer)
  563.       END
  564.  
  565.       SUBROUTINE yesno(answer)
  566.       logical answer
  567.       character*1 ch
  568. 10    continue
  569.       print *, ' Enter <Y> for yes, <N> for no.'
  570.       read  *, ch
  571.       IF ((ch .eq. 'Y') .or. (ch .eq. 'y')) THEN
  572.      answer = .TRUE.
  573.       ELSE IF ((ch .eq. 'N') .or. (ch .eq. 'n')) THEN
  574.      answer = .FALSE.
  575.       ELSE
  576.      call wrong
  577.      GO TO 10
  578.       END IF
  579.       END
  580.  
  581.       SUBROUTINE rdopt
  582.       intrinsic mod
  583.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  584.      integer   iolog,lincnt
  585.      logical   scrnop,diskop,opened,ltrltr
  586.      character line(1:79)
  587.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  588.      integer maxit, iterno
  589.      real    accfac, cnvrg, bigres
  590.      logical finis,divrg
  591.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  592.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  593.      integer shape,size,vsize,inshp,insize,ivsize,
  594.      +       thick,hthick,vthick,square,circle,rctngl
  595.      logical solid, skewed
  596.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  597.      real intrnt, lowert, uppert, prcnt, mint, maxt
  598.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  599.      real temper (1:79,1:79)
  600.      integer tmpshp(1:79,1:8)
  601.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  602.       logical answer
  603.       character ch
  604.  
  605.       call yesno
  606.       return
  607.       ENTRY rdintr                                                      
  608.      print *, ' Enter internal temperature'
  609.      read  *, intrnt
  610.      return
  611.       ENTRY rduppr                                                      
  612.      print *, ' Enter upper edge of shield temperature'
  613.      read  *, uppert
  614.      return
  615.       ENTRY rdlowr                                                      
  616.      print *, ' Enter bottom of shield temperature'
  617.      read  *, lowert
  618.      return
  619.       ENTRY rdpct                                                       
  620. 1310  continue
  621.       print *, ' Enter percent of the shield kept at bottom temp'
  622.       read  *, prcnt
  623.       IF ((prcnt .gt. 100) .or. (prcnt .lt. 0)) THEN
  624.      print *, ' The value must be between 0 and 100.'
  625.      call wrong
  626.      IF (answer .eq. .TRUE.) GO TO 1310
  627.       END IF
  628.       IF (prcnt .eq. 0) THEN
  629.      print *, ' Zero percent implies the bottom temperature has'
  630.      print *, ' no influence.  The lower shield temperature is set'
  631.      print *, ' equal to the upper shield temperature.'
  632.      lowert = uppert
  633.      return
  634.       END IF
  635.       IF (prcnt .eq. 100) THEN
  636.      print *,' One hundred percent implies the upper temperature'
  637.      print *,' has no influence.  The upper shield temperature is'
  638.      print *,' set equal to the lower shield temperature.'
  639.      uppert = lowert
  640.      return
  641.       END IF
  642.       return
  643.       ENTRY rdmxt                                                       
  644. 1410  continue
  645.      print *, ' Enter the maximum number of iterations per pass'
  646.      read  *, maxit
  647.      IF (maxit .lt. 0) THEN
  648.         print *, ' The number of iterations cannot be negative.'
  649.         GO TO 1410
  650.      END IF
  651.      return
  652.       ENTRY rdaccf                                                      
  653. 1510     continue
  654.      print *, ' Enter the acceleration factor (normally 1.84).'
  655.      print *, ' Small changes are recommended.  The acceleration' 
  656.      print *, ' factor should usually fall between 1 and 2.'
  657.      read  *, accfac
  658.      IF (accfac .lt. 0) THEN
  659.         print *, ' The acceleration factor cannot be negative.'
  660.         GO TO 1510
  661.      END IF
  662.      return
  663.       ENTRY rdconv                                                      
  664. 1610     continue
  665.      print *, ' Enter the convergence factor'
  666.      read  *, cnvrg
  667.      IF (cnvrg .lt. 0) THEN
  668.         print *, ' The convergence factor cannot be negative.'
  669.         GO TO 1610
  670.      END IF
  671.      return
  672.       ENTRY rdshp                                                       
  673.      print *, ' ENTER'
  674.      print *, ' <S> for a square pipe/rod.'
  675.      print *, ' <C> for a round(circular) pipe/rod.'
  676.      print *, ' <R> for a rectangular pipe/rod.'
  677. 1710  continue
  678.      read  *, ch
  679.      IF ((ch .eq. 'S') .or. (ch .eq. 's')) THEN
  680.         shape = square
  681.         inshp = shape
  682.         vsize = size
  683.         call gtisze
  684.      ELSE IF ((ch .eq. 'C') .or. (ch .eq. 'c')) THEN
  685.         shape = circle
  686.         inshp = shape
  687.         vsize = size
  688.         call gtisze
  689.      ELSE IF ((ch .eq. 'R') .or. (ch .eq. 'r')) THEN
  690.         shape  = rctngl
  691.         inshp  = shape
  692.         vsize  = .6 * size
  693.         IF (mod(vsize,2) .eq. 0) vsize = vsize + 1
  694.         call gtisze
  695.      ELSE
  696.         call wrong
  697.         GO TO 1710
  698.      END IF
  699.      return
  700.       ENTRY rdishp
  701.      IF (solid .eq. .TRUE.) THEN
  702.         call wrong
  703.         print *,' An internal shape does not exist in a rod.'
  704.         print *,' ''Solid'' must be set to hollow.'
  705.         return
  706.      END IF
  707.      print *, ' ENTER'
  708.      print *, ' <S> for a square core.'
  709.      print *, ' <C> for a round(circular) core.'
  710.      print *, ' <R> for a rectangular core.'
  711. 1760  continue
  712.      read  *, ch
  713.      IF ((ch .eq. 'S') .or. (ch .eq. 's')) THEN
  714.         inshp = square
  715.         ivsize = insize
  716.      ELSE IF ((ch .eq. 'C') .or. (ch .eq. 'c')) THEN
  717.         inshp = circle
  718.         ivsize = insize
  719.      ELSE IF ((ch .eq. 'R') .or. (ch .eq. 'r')) THEN
  720.         inshp = rctngl
  721.         call rdisze
  722.      ELSE
  723.         call wrong
  724.         GO TO 1760
  725.      END IF
  726.      return
  727.  
  728.       ENTRY rdthck                                                      
  729. 1810     continue
  730.      IF (solid .eq. .TRUE.) THEN
  731.         call wrong
  732.         print *,' Wall thickness is predetermined in a rod.'
  733.         print *,' ''Solid'' must be set to hollow.'
  734.         return
  735.      END IF
  736.      print *, ' Enter the thickness of the left side'
  737.      print *, ' Must be an integer > 2 and < ',size-insize+1
  738.      read  *, hthick
  739.      call tstsze(hthick,3,size-insize,answer)
  740.      IF (answer .eq. .FALSE.) THEN
  741.         call wrong
  742.         GO TO 1810
  743.      END IF
  744. 1820   continue
  745.      print *, ' Enter the thickness of the top edge'
  746.      print *, ' Must be an integer > 2 and < ',size-ivsize+1
  747.      read  *, vthick
  748.      call tstsze(vthick,3,vsize-ivsize,answer)
  749.      IF (answer .eq. .FALSE.) THEN
  750.         call wrong
  751.         call tryopt (answer)
  752.         IF (answer .eq. .FALSE.) return
  753.         GO TO 1820
  754.      END IF
  755.      call tstskw
  756.      return
  757.  
  758.       ENTRY rdsold                                                      
  759.      call solopt(solid)
  760.      call gtisze
  761.      return
  762.       END
  763.  
  764.       SUBROUTINE rdsize                                                 
  765.       intrinsic mod
  766.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  767.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  768.      integer shape,size,vsize,inshp,insize,ivsize,
  769.      +       thick,hthick,vthick,square,circle,rctngl
  770.      logical solid, skewed
  771.  
  772. 2010     continue
  773.      print *, ' Enter the external diameter or the '
  774.      print *, ' horizontal size (width) of the pipe/rod.'
  775.      print *, ' The size must be an ODD integer from > 2 and < 80'
  776.      read  *, size
  777.      IF ((size .ge. 80) .or. (size .le. 2)) THEN
  778.         call wrong
  779.         GO TO 2010
  780.      END IF
  781.      IF (mod(size,2) .eq. 0) THEN
  782.         call wrong
  783.         GO TO 2010                                                                        
  784.      END IF
  785.      IF (shape .eq. rctngl) THEN
  786. 2020        continue
  787.         print *, ' Enter the vertical size (height)'
  788.         print *, ' It must be an integer > 2 and < 80.'
  789.         read  *, vsize   
  790.         IF ((size .ge. 80) .or. (size .le. 2)) THEN
  791.            call wrong
  792.            GO TO 2020
  793.         END IF
  794.      ELSE
  795.         vsize = size
  796.      END IF
  797.      call gtisze
  798.      END
  799.  
  800.       SUBROUTINE rdisze                                                 
  801.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  802.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  803.      integer shape,size,vsize,inshp,insize,ivsize,
  804.      +       thick,hthick,vthick,square,circle,rctngl
  805.      logical solid, skewed
  806.       logical answer
  807.       
  808. 2110     continue
  809.      IF (solid .eq. .TRUE.) THEN
  810.         call wrong
  811.         print *,' An internal size does not exist in a rod.'
  812.         print *,' ''Solid'' must be set to hollow.'
  813.         return
  814.      END IF
  815.      GO TO (2120,2130,2140) inshp
  816.      print *, ' Internal shape value = ',inshp
  817. 2120     continue
  818.      print *, ' Enter the length of a side (width or height)'
  819.      print *, ' The size must be an integer > 2 and < ',size-4
  820.      read  *, insize
  821.      call tstsze(insize,1,size-4,answer)
  822.      IF (answer .eq. .FALSE.) THEN
  823.         call wrong
  824.         GO TO 2120
  825.      END IF
  826.      ivsize = insize
  827.      GO TO 2190
  828. 2130     continue
  829.      print *, ' Enter the size (diameter) of the hole including '
  830.      print *, ' the internal core edges'
  831.      print *, ' The size must be an number > 2 and < ',size-4
  832.      read  *, insize
  833.      call tstsze(insize,1,size-4,answer)
  834.      IF (answer .eq. .FALSE.) THEN
  835.         call wrong
  836.         GO TO 2130
  837.      END IF
  838.      ivsize = insize
  839.      GO TO 2190
  840. 2140     continue
  841.      print *, ' Enter the horizontal length'
  842.      read  *, insize
  843.      call tstsze(insize,1,size-4,answer)
  844.      IF (answer .eq. .FALSE.) THEN
  845.         call wrong
  846.         GO TO 2140
  847.      END IF
  848. 2150     continue
  849.      print *, ' Enter the vertical length (height)'
  850.      print *, ' The size must be an number > 2 and < ',vsize-4
  851.      read  *, ivsize
  852.      call tstsze(ivsize,3,vsize-4,answer)
  853.      IF (answer .eq. .FALSE.) THEN
  854.         call wrong
  855.         GO TO 2150
  856.      END IF
  857. 2190     continue
  858.      call gtthck
  859.      END
  860.  
  861.       SUBROUTINE rdrwcl (n,rowcol,begend,size)
  862.       integer n, rowcol, begend, size
  863.       character*6 rc
  864.       character*9 be
  865.  
  866.       IF (begend .eq. 1) THEN
  867.      be = 'beginning'
  868.       ELSE
  869.      be = 'ending   '
  870.       END IF
  871.       IF (rowcol .eq. 1) THEN
  872.      rc = 'row   '
  873.       ELSE
  874.      rc = 'column'
  875.       END IF
  876. 20    continue
  877.       print *, 'Enter ',be,' ',rc
  878.       read *,n
  879.       IF ((n .lt. 1) .or. (n .gt. size)) THEN
  880.      print *,' Values must be greater than 1 and less than',size
  881.      GO TO 20
  882.       END IF
  883.       END 
  884.  
  885.       SUBROUTINE rdlist 
  886.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  887.      integer   iolog,lincnt
  888.      logical   scrnop,diskop,opened,ltrltr
  889.      character line(1:79)
  890.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  891.      real temper (1:79,1:79)
  892.      integer tmpshp(1:79,1:8)
  893.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  894.       logical answer
  895.       real value
  896.       integer row,col
  897.  
  898.       call lstopt (answer)
  899.       IF (answer .eq. .FALSE.) return
  900.       call OpDskI 
  901.       IF (opened .eq. .FALSE.) return
  902.       call initmp
  903. * Read numerical values from disk
  904. 30       continue
  905.      read (iolog, '(I3,I3,f11.5)', END = 40) row, col, value
  906.      temper(row,col) = value
  907.      GO TO 30
  908. 40    continue
  909.       call cldisk
  910.       print *, ' W A R N I N G.  If you try to graph this data you'
  911.       print *, ' may get funny looking results.  (If you must fudge,'
  912.       print *, ' first run a simple problem of the same shapes,sizes'
  913.       print *, ' temperatures etc. as the one you are reading.  You'
  914.       print *, ' can set the number of iterations to zero.)'
  915.       END
  916.  
  917.       SUBROUTINE wrltrs(maxt,mint,tincr)
  918.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  919.      integer   iolog,lincnt
  920.      logical   scrnop,diskop,opened,ltrltr
  921.      character line(1:79)
  922.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  923.      integer maxit, iterno
  924.      real    accfac, cnvrg, bigres
  925.      logical finis,divrg
  926.       integer i
  927.       real maxt, mint, temp, tincr, incr
  928.  
  929.       call clrscr
  930.       IF (finis .eq. .TRUE.) THEN
  931.      call wcvrg
  932.       ELSE
  933.      call wncvrg
  934.       END IF
  935.       call wuppr
  936.       call wintr
  937.       call wlowr
  938.       print *, ' RANGE OF TEMPERATURES'
  939.       temp = mint
  940.       incr = tincr
  941.       do 20 i = 1,16
  942.      call wrltr(temp,incr,i)
  943. 20    continue
  944.       incr = maxt - temp
  945.       call wrltr(temp,incr,17)
  946.       IF (scrnop .eq. .TRUE.) call prentr
  947.       END
  948.  
  949.       SUBROUTINE wrltr(temp1,incr,i)
  950.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  951.      integer   iolog,lincnt
  952.      logical   scrnop,diskop,opened,ltrltr
  953.      character line(1:79)
  954.       real temp1, temp2, incr
  955.       character*1 ch,letter(1:17)
  956.       data letter/ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
  957.      +             'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q' /
  958.  
  959.       ch = letter(i)
  960.       temp2 = temp1 + incr
  961.       IF (scrnop .eq. .TRUE.) 
  962.      +   print 100, ch,' ranges from ',temp1,' to ',temp2,' degrees.'
  963.       IF ((diskop .eq. .TRUE.) .and. (opened .eq. .TRUE.))
  964.      +   write (iolog,100), ch,' ranges from ',temp1,' to ',temp2,
  965.      +   ' degrees.'
  966.       temp1 = temp2
  967. 100   FORMAT (1x,a1,a13,f11.5,a4,f11.5,a1)
  968.       END
  969.  
  970.       SUBROUTINE beep(n)
  971.       intrinsic char
  972.       integer i,n
  973.       character*1 lebeep
  974.       lebeep = char(7)
  975.       do 10 i = 1,n
  976.      print *,lebeep
  977. 10    continue
  978.       END
  979.  
  980.       SUBROUTINE wrbas
  981.       print *, ' BASIC PARAMETERS'
  982.       call wshape
  983.       call wsolid
  984.       call wuppr
  985.       call wintr
  986.       call wlowr
  987.       call wprcnt
  988.       END
  989.  
  990.       SUBROUTINE writer
  991.       print *, ' ITERATION PARAMETERS'
  992.       call wmaxit
  993.       call waccf
  994.       call wconv
  995.       END
  996.  
  997.       SUBROUTINE wrshp
  998.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  999.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1000.      integer shape,size,vsize,inshp,insize,ivsize,
  1001.      +       thick,hthick,vthick,square,circle,rctngl
  1002.      logical solid, skewed
  1003.  
  1004.       print *, ' SHAPE PARAMETERS'
  1005.       call wshape
  1006.       call wsize
  1007.       call wsolid
  1008.       IF (solid .eq. .TRUE.) return
  1009.       call wishpe
  1010.       call wisize
  1011.       call wskew
  1012.       call wthick
  1013.       END
  1014.  
  1015.       SUBROUTINE wshape
  1016.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1017.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1018.      integer shape,size,vsize,inshp,insize,ivsize,
  1019.      +       thick,hthick,vthick,square,circle,rctngl
  1020.      logical solid, skewed
  1021.  
  1022.       print *, ' The External '
  1023.       GO TO (10,20,30) shape
  1024.       print '(14x,a15)', '+Shape = ',shape
  1025.       GO TO 90
  1026.  
  1027.       ENTRY wishpe
  1028.       IF (solid .eq. .TRUE.) GO TO 90
  1029.       print *, ' The Internal '
  1030.       GO TO (10,20,30) inshp
  1031.       print '(14x,a15)', '+Shape = ',inshp
  1032.       GO TO 90
  1033.  
  1034. 10    continue
  1035.       print '(14x,a15)', '+Shape = Square'
  1036.       GO TO 90
  1037. 20    continue
  1038.       print '(14x,a14)', '+Shape = Round'
  1039.       GO TO 90
  1040. 30    continue
  1041.       print '(14x,a20)', '+Shape = Rectangular'
  1042.       GO TO 90
  1043. 90    continue
  1044.       END
  1045.  
  1046.       SUBROUTINE wsolid
  1047.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1048.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1049.      integer shape,size,vsize,inshp,insize,ivsize,
  1050.      +       thick,hthick,vthick,square,circle,rctngl
  1051.      logical solid, skewed
  1052.  
  1053.       IF (solid .eq. .TRUE.) THEN
  1054.      print *, ' The core of the shield = Solid'
  1055.       ELSE
  1056.      print *, ' The core of the shield = Hollow'      
  1057.       END IF   
  1058.       END
  1059.  
  1060.       SUBROUTINE wparam
  1061.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1062.      integer   iolog,lincnt
  1063.      logical   scrnop,diskop,opened,ltrltr
  1064.      character line(1:79)
  1065.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1066.      integer maxit, iterno
  1067.      real    accfac, cnvrg, bigres
  1068.      logical finis,divrg
  1069.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1070.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1071.      integer shape,size,vsize,inshp,insize,ivsize,
  1072.      +       thick,hthick,vthick,square,circle,rctngl
  1073.      logical solid, skewed
  1074.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1075.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1076.  
  1077.       GO TO 90
  1078.       ENTRY wintr
  1079.       print *, ' Internal temperature = ',intrnt
  1080.       GO TO 90
  1081.       ENTRY wuppr
  1082.       print *, ' Upper    temperature = ',uppert
  1083.       GO TO 90
  1084.       ENTRY wlowr
  1085.       print *, ' Lower    temperature = ',lowert
  1086.       GO TO 90
  1087.       ENTRY wprcnt
  1088.       print *, ' Amount of pipe/rod that is buried/immersed = ',prcnt
  1089.       GO TO 90
  1090.       ENTRY wmaxit
  1091.       print *, ' The number of iterations in one pass = ',maxit
  1092.       GO TO 90
  1093.       ENTRY waccf
  1094.       print *, ' The acceration factor = ',accfac
  1095.       GO TO 90
  1096.       ENTRY wconv
  1097.       print *, ' The convergence criterion is ',cnvrg,' degrees.'
  1098.       GO TO 90
  1099.  
  1100.       ENTRY wsize
  1101.      print *, ' The external horizontal size = ',size
  1102.       ENTRY wvsize
  1103.      print *, ' The external vertical   size = ',vsize
  1104.      GO TO 90
  1105.  
  1106.       ENTRY wisize
  1107.      print *, ' The internal horizontal size = ',insize
  1108.       ENTRY wivsze
  1109.      print *, ' The internal vertical   size = ',ivsize
  1110.      GO TO 90
  1111.  
  1112.       ENTRY wskew
  1113.      IF (solid .eq. .TRUE.) GO TO 90
  1114.      IF (skewed .eq. .TRUE.) THEN
  1115.         print *,' The internal core is not centered horizontally.'
  1116.      ELSE
  1117.         print *,' The internal core is centered horizontally.'
  1118.      END IF
  1119.      GO TO 90
  1120.  
  1121.       ENTRY wthick
  1122.      print *, ' The left side horizontal thickness = ',hthick
  1123.       ENTRY wvthck
  1124.      print *, ' The top       vertical   thickness = ',vthick
  1125.      GO TO 90
  1126.        
  1127.       ENTRY wcvrg
  1128.      print *, ' With convergence value = ', cnvrg,' convergence' 
  1129.      print *, ' was achieved in ', iterno,' iterations.'
  1130.      IF ((diskop .eq. .TRUE.) .and. (opened .eq. .TRUE.)) THEN
  1131.         write(iolog,*) ' With convergence value = ', cnvrg,
  1132.      +      ' convergence'
  1133.         write (iolog,*) ' was achieved in ', iterno,' iterations.'
  1134.      END IF
  1135.      GO TO 90
  1136.       ENTRY wncvrg
  1137.      print *, '+No convergence yet in ', iterno, ' iterations.'
  1138.      print *, ' Current convergence is ', bigres, ' degrees.'
  1139.      print *, ' Convergence goal is ',cnvrg,' degrees.'
  1140.      IF ((diskop .eq. .TRUE.) .and. (opened .eq. .TRUE.)) THEN
  1141.         write (iolog,*) ' No convergence yet in ', iterno, 
  1142.      +      ' iterations.'
  1143.         write (iolog,*) ' Current convergence is ', bigres, 
  1144.      +      ' degrees.'
  1145.         write (iolog,*) ' Convergence goal is ',cnvrg,' degrees.'
  1146.      END IF
  1147.      GO TO 90
  1148. 90    continue
  1149.       END
  1150.       
  1151.       SUBROUTINE wdivrg (row,col,tempt)
  1152.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1153.      integer maxit, iterno
  1154.      real    accfac, cnvrg, bigres
  1155.      logical finis,divrg
  1156.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1157.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1158.       integer row,col
  1159.       real tempt
  1160.      
  1161.       call clrscr
  1162.       print *,' Solution is diverging.  Check problem setup.'
  1163.       print *,' If necessary modify the acceleration factor'
  1164.       print *,' and/or the convergence criterion.'
  1165.       print *,' Maximum  temperature = ',maxt
  1166.       print *,' Minimum  temperature = ',mint
  1167.       print *,' Computed temperature = ',tempt
  1168.       print *,' Row = ',row,'  Column = ',col
  1169.       print *,' Iteration number = ',interno
  1170.       call beep(4)
  1171.       call prentr
  1172.       END
  1173.  
  1174.       SUBROUTINE wrtmsh
  1175.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1176.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1177.      integer shape,size,vsize,inshp,insize,ivsize,
  1178.      +       thick,hthick,vthick,square,circle,rctngl
  1179.      logical solid, skewed
  1180.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1181.      real temper (1:79,1:79)
  1182.      integer tmpshp(1:79,1:8)
  1183.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1184.       integer i
  1185.       do 10 i = 1,vsize
  1186.      print *,' ',i,
  1187.      +           ' ',tmpshp(i,1),' ',tmpshp(i,2),' ',tmpshp(i,3),
  1188.      +           ' ',tmpshp(i,4),' ',tmpshp(i,5),' ',tmpshp(i,6),
  1189.      +           ' ',tmpshp(i,7),' ',tmpshp(i,8)
  1190. 10    continue
  1191.       END
  1192.  
  1193.       SUBROUTINE wrong
  1194.       print *, ' You entered and invalid option or value.'
  1195.       call prentr
  1196.       END
  1197.  
  1198.       SUBROUTINE initar
  1199.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1200.      integer   iolog,lincnt
  1201.      logical   scrnop,diskop,opened,ltrltr
  1202.      character line(1:79)
  1203.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1204.      real temper (1:79,1:79)
  1205.      integer tmpshp(1:79,1:8)
  1206.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1207.       integer i,j
  1208.       character blank
  1209.       data blank /' '/
  1210.  
  1211.       return
  1212.       ENTRY initln                                                      
  1213.       do 10 i = 1,79
  1214.      line(i) = blank
  1215. 10    continue
  1216.       return
  1217.       ENTRY initts                                                      
  1218.       DO 20 j = 1,8
  1219.       DO 15 i = 1,79
  1220.      tmpshp(i,j) = 0
  1221. 15    continue
  1222. 20    continue
  1223.       return
  1224.       ENTRY initmp                                                      
  1225.       DO 30 i = 1,79
  1226.       DO 25 j = 1,79
  1227.      temper(i,j) = 0
  1228. 25    continue
  1229. 30    continue
  1230.       return
  1231.       END
  1232.  
  1233.       SUBROUTINE initsl
  1234.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1235.      integer   iolog,lincnt
  1236.      logical   scrnop,diskop,opened,ltrltr
  1237.      character line(1:79)
  1238.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1239.      integer maxit, iterno
  1240.      real    accfac, cnvrg, bigres
  1241.      logical finis,divrg
  1242.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1243.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1244.      integer shape,size,vsize,inshp,insize,ivsize,
  1245.      +       thick,hthick,vthick,square,circle,rctngl
  1246.      logical solid, skewed
  1247.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1248.      real intrnt, lowert, uppert, prcnt, mint, maxt
  1249.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1250.      real temper (1:79,1:79)
  1251.      integer tmpshp(1:79,1:8)
  1252.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1253.       
  1254.       return
  1255.       ENTRY initio
  1256.       iolog  = 20
  1257.       lincnt = 0
  1258.       scrnop = .TRUE.
  1259.       diskop = .FALSE.
  1260.       ltrltr = .FALSE.
  1261.       return
  1262. *     Initialize Basic Parameters
  1263.       ENTRY initbs
  1264.       uppert = 150
  1265.       intrnt = -350
  1266.       lowert = 3600
  1267.       prcnt  = 1
  1268.       return
  1269.       ENTRY initit
  1270.       maxit  = 200
  1271.       accfac = 1.84
  1272.       cnvrg  = 0.1
  1273.       finis = .TRUE.
  1274.       return
  1275.       ENTRY initsh
  1276.       shape  = rctngl
  1277.       size   = 79
  1278.       vsize  = 51
  1279.       thick  = 29
  1280.       inshp  = square
  1281.       insize = 23
  1282.       ivsize = insize
  1283.       hthick = 29
  1284.       vthick = 15
  1285.       solid  = .FALSE.
  1286.       skewed = .FALSE.
  1287.       return
  1288.       END
  1289.  
  1290.       SUBROUTINE initlm(rowb,colb,rowe,cole)
  1291.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1292.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1293.      integer shape,size,vsize,inshp,insize,ivsize,
  1294.      +       thick,hthick,vthick,square,circle,rctngl
  1295.      logical solid, skewed
  1296.       integer rowb,colb,rowe,cole
  1297.       rowb = 1
  1298.       colb = 1
  1299.       rowe = vsize
  1300.       cole = size
  1301.       END
  1302.  
  1303.       SUBROUTINE tstskw 
  1304.       intrinsic mod
  1305.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1306.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1307.      integer shape,size,vsize,inshp,insize,ivsize,
  1308.      +       thick,hthick,vthick,square,circle,rctngl
  1309.      logical solid, skewed
  1310.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1311.      real temper (1:79,1:79)
  1312.      integer tmpshp(1:79,1:8)
  1313.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1314.       integer x
  1315.  
  1316.       IF (solid .eq. .TRUE.) THEN
  1317.      skewed = .FALSE.
  1318.      return
  1319.       END IF
  1320.       x = size-(insize-2)
  1321.       skewed = .TRUE.
  1322.       IF (mod(x,2) .ne. 0) return
  1323.       x = x/2
  1324.       IF (hthick .eq. x) skewed = .FALSE.
  1325.       END
  1326.  
  1327.       SUBROUTINE tstrc (n1,n2,rowcol,answer)
  1328.       integer n1,n2,rowcol
  1329.       logical answer
  1330.       character*6 rc
  1331.  
  1332.       IF (rowcol .eq. 1) THEN
  1333.      rc = 'row '
  1334.       ELSE
  1335.      rc = 'column '
  1336.       END IF
  1337.       answer = .TRUE.
  1338.       IF (n1 .gt. n2) THEN
  1339.      print *, ' The beginning ', rc, n1, 
  1340.      +   ' is greater than the ending  ', rc, n2
  1341.      answer = .FALSE.
  1342.       END IF 
  1343.       END
  1344.  
  1345.       SUBROUTINE tstsze (val1,val2,val3,answer)
  1346.       integer val1,val2,val3
  1347.       logical answer
  1348.       answer = .TRUE.
  1349.       IF ((val1 .lt. val2) .or. (val1 .gt. val3)) answer = .FALSE.
  1350.       END
  1351.  
  1352.       SUBROUTINE inwall(row,col,answer)
  1353.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1354.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1355.      integer shape,size,vsize,inshp,insize,ivsize,
  1356.      +       thick,hthick,vthick,square,circle,rctngl
  1357.      logical solid, skewed
  1358.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1359.      real temper (1:79,1:79)
  1360.      integer tmpshp(1:79,1:8)
  1361.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1362.       integer row,col
  1363.       logical answer
  1364.  
  1365.       IF ((row .le. 1) .or. (row .ge. vsize)) 
  1366.      +   GO TO 90
  1367.       IF (tmpshp(row,wlb) .le. 0)
  1368.      +   GO TO 90
  1369.       IF ((col .lt. tmpshp(row,wlb)) .or. (col .gt. tmpshp(row,wre)))
  1370.      +   GO TO 90
  1371.       IF (solid .eq. .TRUE.) 
  1372.      +   GO TO 95
  1373.       IF (((row .ge. vthick) .and. (row .le. vthick+ivsize-1)) .and.
  1374.      +   ((col .ge. tmpshp(row,ils)) .and. (col .le. tmpshp(row,irs))))
  1375.      +   GO TO 90
  1376.       GO TO 95
  1377. 90    continue
  1378.       answer = .FALSE.
  1379.       return
  1380. 95    continue
  1381.       answer = .TRUE.
  1382.       return
  1383.       END
  1384.  
  1385.       SUBROUTINE onwall(row,col,answer)
  1386.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1387.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1388.      integer shape,size,vsize,inshp,insize,ivsize,
  1389.      +       thick,hthick,vthick,square,circle,rctngl
  1390.      logical solid, skewed
  1391.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1392.      real temper (1:79,1:79)
  1393.      integer tmpshp(1:79,1:8)
  1394.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1395.       integer row,col
  1396.       logical answer
  1397.  
  1398.       IF ((row .lt. 1) .or. (row .gt. vsize))
  1399.      +   GO TO 90
  1400.       IF ((col .lt. 1) .or. (col .gt. size))
  1401.      +   GO TO 90
  1402.       IF (solid .eq. .TRUE.) GO TO 95
  1403.       IF (((row .gt. vthick) .and. (row .lt. vthick+ivsize-1)) .and.
  1404.      +   ((col .gt. tmpshp(row,ils)) .and. (col .lt. tmpshp(row,irs))))
  1405.      +   GO TO 90
  1406.       GO TO 95
  1407. 90    continue
  1408.       answer = .FALSE.
  1409.       return
  1410. 95    continue
  1411.       answer = .TRUE.
  1412.       return
  1413.       END
  1414.  
  1415.       SUBROUTINE gtbas
  1416.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1417.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1418.      integer shape,size,vsize,inshp,insize,ivsize,
  1419.      +       thick,hthick,vthick,square,circle,rctngl
  1420.      logical solid, skewed
  1421.       integer option
  1422.       logical answer
  1423.  
  1424.       call basopt(answer)
  1425.       IF (answer .eq. .FALSE.) return
  1426. 5     continue
  1427.       call clrscr
  1428.       call wrbas
  1429.       print *, ' ENTER'
  1430.       print *, ' 1  To accept all variables'
  1431.       print *, ' 2  To reinitialize all basic variables'
  1432.       print *, ' 3  To change all variables'
  1433.       print *, ' 4  To change external and internal shield shapes'
  1434.       print *, ' 5  To change Top Edge    temperature'
  1435.       print *, ' 6  To change Internal    temperature'
  1436.       print *, ' 7  To change Bottom Edge temperature'
  1437.       print *, ' 8  To change Percent of Shield at Bottom Temperature'
  1438.       print *, ' 9  To change Solid Option'
  1439.       read  *, Option
  1440.       GO TO (90,10,15,20,25,30,35,40,45) Option
  1441.       call wrong
  1442.       GO TO 5
  1443. 10    continue
  1444.       call initbs
  1445.       GO TO 5
  1446. 15    continue
  1447.       call rdshp
  1448.       call rduppr
  1449.       call rdintr
  1450.       call rdlowr
  1451.       call rdpct
  1452.       call rdsold
  1453.       GO TO 5
  1454. 20    call rdshp
  1455.       GO TO 5
  1456. 25    call rduppr
  1457.       GO TO 5
  1458. 30    call rdintr
  1459.       GO TO 5
  1460. 35    call rdlowr
  1461.       GO TO 5
  1462. 40    call rdpct
  1463.       GO TO 5
  1464. 45    call rdsold
  1465.       GO TO 5
  1466. 90    continue
  1467.       inshp = shape
  1468.       END
  1469.  
  1470.       SUBROUTINE gtiter
  1471.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1472.      integer maxit, iterno
  1473.      real    accfac, cnvrg, bigres
  1474.      logical finis,divrg
  1475.       integer option
  1476.       logical answer
  1477.  
  1478.       call itropt (answer)
  1479.       IF (answer .eq. .FALSE.) return
  1480. 10    continue
  1481.       call clrscr
  1482.       call writer
  1483.       print *, ' ENTER'
  1484.       print *, ' 1  To accept all variables'
  1485.       print *, ' 2  To reinitialize all iteration variables'
  1486.       print *, ' 3  To change all variables'
  1487.       print *, ' 4  To change number of iterations'
  1488.       print *, ' 5  To change the acceleration factor'
  1489.       print *, ' 6  To change the convergence factor'
  1490.       read  *, option
  1491.       GO TO (90,20,30,40,50,60) option
  1492.       call wrong
  1493.       GO TO 10
  1494. 20    continue
  1495.       call initit
  1496.       GO TO 10
  1497. 30    continue
  1498.       call rdmxt
  1499.       call rdaccf
  1500.       call rdconv
  1501.       GO TO 10
  1502. 40    continue
  1503.       call rdmxt
  1504.       GO TO 10
  1505. 50    continue
  1506.       call rdaccf
  1507.       GO TO 10
  1508. 60    continue
  1509.       call rdconv
  1510.       GO TO 10
  1511. 90    continue
  1512.       END
  1513.  
  1514.       SUBROUTINE gtshp
  1515.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1516.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1517.      integer shape,size,vsize,inshp,insize,ivsize,
  1518.      +       thick,hthick,vthick,square,circle,rctngl
  1519.      logical solid, skewed
  1520.       integer option
  1521.       logical answer
  1522.  
  1523.       call shpopt (answer)
  1524.       IF (answer .eq. .FALSE.) return
  1525. 10    continue
  1526.       call clrscr
  1527.       call wrshp
  1528.       print *, ' ENTER'
  1529.       print *, ' 1  To accept all variables'
  1530.       print *, ' 2  To reinitialize all shape variables'
  1531.       print *, ' 3  To change all variables'
  1532.       print *, ' 4  To change external shield shape'
  1533.       print *, ' 5  To change external shield size'
  1534.       print *, ' 6  To change internal core shape'
  1535.       print *, ' 7  To change internal core size'
  1536.       print *, ' 8  To change shield wall thickness'
  1537.       print *, ' 9  To change solid option'
  1538.       read  *, option
  1539.       GO TO (90,15,20,25,30,35,40,50,60) option
  1540.       call wrong
  1541.       GO TO 10
  1542. 15    continue
  1543.       call initsh
  1544.       GO TO 10
  1545. 20    continue
  1546.       call rdshp
  1547.       call rdsize
  1548.       call rdishp
  1549.       call rdisze
  1550.       call rdthck
  1551.       call rdsold
  1552.       GO TO 10
  1553. 25    continue
  1554.       call rdshp
  1555.       GO TO 10
  1556. 30    continue
  1557.       call rdsize
  1558.       GO TO 10
  1559. 35    continue
  1560.       call rdishp
  1561.       GO TO 10
  1562. 40    continue
  1563.       call rdisze
  1564.       GO TO 10
  1565. 50    continue
  1566.       call rdthck
  1567.       GO TO 10
  1568. 60    continue
  1569.       call rdsold
  1570.       GO TO 10
  1571. 90    continue
  1572.       IF ((insize .eq. 0) .or. (ivsize .eq. 0)) solid = .TRUE.
  1573.       END
  1574.  
  1575.       SUBROUTINE gtisze
  1576.       intrinsic mod
  1577.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1578.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1579.      integer shape,size,vsize,inshp,insize,ivsize,
  1580.      +       thick,hthick,vthick,square,circle,rctngl
  1581.      logical solid, skewed
  1582.  
  1583.      IF (solid .eq. .TRUE.) THEN
  1584.         insize = 0
  1585.         ivsize = 0
  1586.      ELSE
  1587.         insize = .4 * size
  1588.         IF (mod(insize,2) .eq. 0) insize = insize + 1
  1589.         ivsize = .4 * vsize
  1590.         IF (mod(ivsize,2) .eq. 0) ivsize = ivsize + 1
  1591.      END IF
  1592.      call gtthck
  1593.       END
  1594.  
  1595.       SUBROUTINE gtthck
  1596.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1597.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1598.      integer shape,size,vsize,inshp,insize,ivsize,
  1599.      +       thick,hthick,vthick,square,circle,rctngl
  1600.      logical solid, skewed
  1601.  
  1602.      IF (solid .eq. .TRUE.) THEN
  1603.         hthick = size
  1604.         vthick = vsize
  1605.      ELSE
  1606.         hthick = ( size - (insize - 2))/2
  1607.         vthick = (vsize - (ivsize - 2))/2
  1608.      END IF
  1609.      END
  1610.  
  1611.       SUBROUTINE gtioop (answer)
  1612.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1613.      integer   iolog,lincnt
  1614.      logical   scrnop,diskop,opened,ltrltr
  1615.      character line(1:79)
  1616.       logical answer,ans
  1617.                          
  1618. 10    continue
  1619.       call scropt(scrnop)
  1620.       call dskopt(diskop)
  1621.       IF (diskop .eq. .TRUE.) call OpDskO
  1622.       IF ((opened .eq. .FALSE.) .and. (scrnop .eq. .FALSE.)) THEN
  1623.      print *, ' No device available for output'
  1624.      call tryopt (ans)
  1625.      IF (ans .eq. .TRUE.) GO TO 10
  1626.      answer = .FALSE.
  1627.       ELSE
  1628.      answer = .TRUE.
  1629.       END IF
  1630.       END 
  1631.  
  1632.       SUBROUTINE gtindx(row, collb, colle, colrb, colre, pieces)
  1633.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1634.      real temper (1:79,1:79)
  1635.      integer tmpshp(1:79,1:8)
  1636.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1637.       integer row,colrb,colre,collb,colle,pieces
  1638.                   
  1639.       IF (tmpshp(row,ils) .eq. 0) THEN
  1640.      collb  = tmpshp(row,wlb)
  1641.      colle  = tmpshp(row,wre)
  1642.      colrb  = 0
  1643.      colre  = 0
  1644.      pieces = 1
  1645.      return
  1646.       ELSE
  1647.      collb  = tmpshp(row,wlb)
  1648.      colle  = tmpshp(row,wle)
  1649.      colrb  = tmpshp(row,wrb)
  1650.      colre  = tmpshp(row,wre)
  1651.      pieces = 2
  1652.       END IF
  1653.       END
  1654.  
  1655.       SUBROUTINE gtlmts(rowb,colb,rowe,cole)
  1656.       logical answer
  1657.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1658.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1659.      integer shape,size,vsize,inshp,insize,ivsize,
  1660.      +       thick,hthick,vthick,square,circle,rctngl
  1661.      logical solid, skewed
  1662.       integer rowb,colb,rowe,cole,option,r,c,b,e
  1663.       data r/1/,c/2/,b/1/,e/2/
  1664.  
  1665. 20    continue
  1666.       call initlm (rowb,colb,rowe,cole)
  1667.       GO TO 80
  1668. 30    continue
  1669.       call rdrwcl (rowb,r,b,size)
  1670.       call rdrwcl (colb,c,b,vsize)
  1671.       call rdrwcl (rowe,r,e,size)
  1672.       call rdrwcl (cole,c,e,vsize)
  1673.       GO TO 80
  1674. 40    continue
  1675.       call rdrwcl (rowb,r,b,size)
  1676.       GO TO 80
  1677. 50    continue
  1678.       call rdrwcl (colb,c,b,vsize)
  1679.       GO TO 80
  1680. 60    continue
  1681.       call rdrwcl (rowe,r,e,size)
  1682.       GO TO 80
  1683. 70    continue
  1684.       call rdrwcl (cole,c,e,vsize)
  1685.       GO TO 80
  1686. 80    continue
  1687.       call clrscr
  1688.       print *, ' Beginning row    = ', rowb
  1689.       print *, ' Beginning column = ', colb
  1690.       print *, ' Ending row       = ', rowe
  1691.       print *, ' Ending column    = ', cole
  1692.       print *
  1693.       call tstrc (rowb,rowe,r,answer)
  1694.       IF (answer .eq. .FALSE.) GO TO 30
  1695.       call tstrc (colb,cole,c,answer)
  1696.       IF (answer .eq. .FALSE.) GO TO 30
  1697.       print *, ' ENTER'
  1698.       print *, ' 1  To accept all values.'
  1699.       print *, ' 2  To change all values.'
  1700.       print *, ' 3  To change beginning row.'
  1701.       print *, ' 4  To change beginning column.'
  1702.       print *, ' 5  To change ending row.'
  1703.       print *, ' 6  To change ending column.'
  1704.       read  *, option
  1705.       GO TO (90,30,40,50,60,70) option
  1706.       call wrong
  1707.       GO TO 80
  1708. 90    continue
  1709.       END
  1710.  
  1711.       SUBROUTINE mkrnd (a,b,d,i,j)
  1712.       intrinsic abs, sqrt, nint, real
  1713.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1714.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1715.      integer shape,size,vsize,inshp,insize,ivsize,
  1716.      +       thick,hthick,vthick,square,circle,rctngl
  1717.      logical solid, skewed
  1718.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1719.      real temper (1:79,1:79)
  1720.      integer tmpshp(1:79,1:8)
  1721.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1722.       integer row,rowb,row2,rowe,col,colm,a,b,d,i,j,x,xc,cola
  1723.       real r,y
  1724.  
  1725.       rowb = b 
  1726.       rowe = b + (d-1)/2
  1727.       xc   = a + (d-1)/2
  1728.       r    = rowe-rowb
  1729.       row2 = rowb + (r + 1)/2
  1730.       cola = 0
  1731.       do 30 row = rowb+1,rowe-1
  1732.      y = rowe - row
  1733.      x = nint(sqrt(r*r-y*y))
  1734.      col  = xc-x
  1735.      colm = size-col+1
  1736.      tmpshp(row,        i) = col
  1737.      tmpshp(vsize-row+1,i) = col
  1738.      tmpshp(row,        j) = colm
  1739.      tmpshp(vsize-row+1,j) = colm
  1740.      IF (col .eq. a) cola = cola + 1
  1741. 30    continue
  1742.       tmpshp(rowe,i) = a
  1743.       tmpshp(rowe,j) = size-a+1
  1744.       cola = cola + 1  
  1745.       col  = xc - cola
  1746.       colm = size-col+1
  1747.       tmpshp(rowb,        i) = col
  1748.       tmpshp(vsize-rowb+1,i) = col
  1749.       tmpshp(rowb,        j) = colm
  1750.       tmpshp(vsize-rowb+1,j) = colm
  1751.       END
  1752.  
  1753.       SUBROUTINE mkrect (a,b,hs,vs,i,j)
  1754.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1755.      real temper (1:79,1:79)
  1756.      integer tmpshp(1:79,1:8)
  1757.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1758.       integer row,a,b,hs,vs,i,j
  1759.  
  1760.       do 40 row = b,b+vs-1
  1761.      tmpshp(row,i) = a
  1762.      tmpshp(row,j) = a+hs-1
  1763. 40    continue
  1764.       END
  1765.  
  1766.       SUBROUTINE mkwall
  1767.       intrinsic abs
  1768.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1769.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1770.      integer shape,size,vsize,inshp,insize,ivsize,
  1771.      +       thick,hthick,vthick,square,circle,rctngl
  1772.      logical solid, skewed
  1773.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1774.      real temper (1:79,1:79)
  1775.      integer tmpshp(1:79,1:8)
  1776.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1777.       integer row,midrow,diff
  1778.  
  1779.       midrow = (vsize+1)/2
  1780.       do 50 row = 2, vsize-1
  1781.      diff = tmpshp(row,els)-tmpshp(row-1,els)
  1782.      IF (diff)10,20,30
  1783. 10       continue
  1784.         tmpshp(row,wlb) = tmpshp(row-1,els)
  1785.         tmpshp(row,wre) = tmpshp(row-1,ers)
  1786.         GO TO 40
  1787. 20       continue
  1788.         tmpshp(row,wlb) = tmpshp(row,els)+1
  1789.         tmpshp(row,wre) = tmpshp(row,ers)-1
  1790.         GO TO 40
  1791. 30       continue
  1792.         tmpshp(row,wlb) = tmpshp(row+1,els)
  1793.         tmpshp(row,wre) = tmpshp(row+1,ers)
  1794.         GO TO 40
  1795. 40       continue
  1796.      IF (tmpshp(row,ils) .eq. 0) THEN
  1797.         tmpshp(row,irs) = 0
  1798.         tmpshp(row,wle) = 0
  1799.         tmpshp(row,wrb) = 0
  1800.      ELSE
  1801.         tmpshp(row,wle) = tmpshp(row,ils)-1
  1802.         tmpshp(row,wrb) = tmpshp(row,irs)+1
  1803.      END IF
  1804. 50    continue
  1805.       END                    
  1806.  
  1807.       SUBROUTINE NOP
  1808.       END
  1809.  
  1810.       SUBROUTINE ClrScr
  1811.       print '(''1'')'
  1812.       END
  1813.  
  1814.       SUBROUTINE PrEntr
  1815.       character*15 RName
  1816.      parameter(RName = 'PrEntr     ')
  1817.  
  1818.       print *, 'Press Enter to Continue'
  1819.       Read *
  1820.       END
  1821.  
  1822.